home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Delphi Informant Complete 1995 - 2000
/
Delphi Informant Complete 1995 to 2000.iso
/
Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar
/
1998
/
Nov
/
di9811gd
/
Example2
/
Unit1.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1998-04-25
|
6KB
|
215 lines
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
{ TLightThread }
{* For easy management of threads. *}
{* Allows a thread to be "created" with a passed thread function. The *}
{* function will exit cleanly when ThreadExiting is set to true, or *}
{* "nastily" after a timeout of ThreadExitTimeout milliseconds. *}
{* For the purposes of this example, though, we are pretty assured that the *}
{* ThreadFunc used will always exit cleanly... (How else to demonstrate *}
{* a thread-safe DLL?) *}
TLightThread = class(TObject)
protected
FThreadHandle: THandle;
FThreadID: DWord;
FCS: TRTLCriticalSection;
FThreadExiting: Boolean;
function GetThreadExiting: Boolean;
public
constructor Create(ThreadFunc: TThreadFunc);
destructor Destroy; override;
property ThreadExiting: Boolean read GetThreadExiting;
property ThreadHandle: THandle read FThreadHandle;
property ThreadID: DWord read FThreadID;
end;
{ TForm1 }
TForm1 = class(TForm)
btnLoad: TButton;
btnUnload: TButton;
lbThreads: TListBox;
Label1: TLabel;
btnNewThread: TButton;
btnCloseThread: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnLoadClick(Sender: TObject);
procedure btnUnloadClick(Sender: TObject);
procedure btnNewThreadClick(Sender: TObject);
procedure btnCloseThreadClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
LibHandle: THandle;
ThreadList: TList;
procedure FreeLib;
procedure NewThread;
procedure CloseThread(Idx: Integer); { Close indexed thread. }
procedure CloseThreads;
end;
var
Form1: TForm1;
const
ThreadSleepLength = 50; // 50 ms.
ThreadExitTimeout = 10000;
implementation
{$R *.DFM}
function ThreadFunc(Parameter: Pointer): Integer;
begin
while (not TLightThread(Parameter).ThreadExiting) do
Sleep(ThreadSleepLength);
result := 0;
end;
{ TLightThread }
constructor TLightThread.Create(ThreadFunc: TThreadFunc);
begin
InitializeCriticalSection(FCS);
FThreadExiting := False;
try
FThreadHandle :=
BeginThread(nil, 0, ThreadFunc, Pointer(Self), 0, FThreadID);
except
on E: Exception do begin
DeleteCriticalSection(FCS);
raise;
end;
end;
end;
destructor TLightThread.Destroy;
begin
EnterCriticalSection(FCS);
try
FThreadExiting := True;
finally
LeaveCriticalSection(FCS);
end;
WaitForSingleObject(FThreadHandle, ThreadExitTimeout);
CloseHandle(FThreadHandle);
DeleteCriticalSection(FCS);
inherited;
end;
function TLightThread.GetThreadExiting: Boolean;
begin
EnterCriticalSection(FCS);
try
result := FThreadExiting;
finally
LeaveCriticalSection(FCS);
end;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
IsMultiThread := True;
LibHandle := 0;
ThreadList := TList.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeLib; // Free the library, if necessary
CloseThreads; // Guarantee that threads are closed.
ThreadList.Free; // Free the list of threads.
end;
procedure TForm1.btnLoadClick(Sender: TObject);
begin
if LibHandle = 0 then
LibHandle := LoadLibrary('Dll2.dll');
end;
procedure TForm1.btnUnloadClick(Sender: TObject);
begin
FreeLib; // Free the library, if necessary
end;
procedure TForm1.btnNewThreadClick(Sender: TObject);
begin
NewThread;
end;
procedure TForm1.btnCloseThreadClick(Sender: TObject);
begin
CloseThread(lbThreads.ItemIndex);
end;
procedure TForm1.FreeLib;
var
i, Cnt: Integer;
begin
{* In comments is the appropriate way for a calling application
to free its library when it has multiple threads; however, for
the purpose of the example, we _just_ unload the library *}
FreeLibrary(LibHandle);
LibHandle := 0;
{if LibHandle <> 0 then begin
try
Cnt := ThreadList.Count;
for i := 0 to Cnt - 1 do CloseThread(0);
FreeLibrary(LibHandle);
finally
LibHandle := 0;
end;
end;}
end;
procedure TForm1.NewThread;
var
Thd: TLightThread;
begin
{ Create a thread }
Thd := TLightThread.Create(ThreadFunc);
{ If thread was created successfully, then add the thread handle to
ThreadList, increment thread count and add an "identifier" to
the ListBox (for identification purposes only). }
ThreadList.Add(Pointer(Thd));
lbThreads.Items.Add('Thread #' + IntToStr(Thd.ThreadHandle));
lbThreads.ItemIndex := lbThreads.Items.Count - 1;
end;
procedure TForm1.CloseThread(Idx: Integer);
begin
if (Idx >= 0) and (Idx < ThreadList.Count) then begin
TLightThread(ThreadList.Items[Idx]).Free;
ThreadList.Delete(Idx); ThreadList.Pack;
lbThreads.Items.Delete(Idx);
if (Idx = ThreadList.Count) then
lbThreads.ItemIndex := Idx - 1
else
lbThreads.ItemIndex := Idx;
end;
end;
procedure TForm1.CloseThreads;
var
i, Cnt: Integer;
begin
Cnt := ThreadList.Count;
for i := 0 to Cnt - 1 do CloseThread(0);
end;
initialization
IsMultiThread := True;
end.